﻿module CssParser

(* 
http://www.w3.org/TR/CSS21/grammar.html
*)

open CssTypes
open System.Text.RegularExpressions
open FParsec
open FParsec.Primitives
open FParsec.CharParsers

let preProcess str =     
    let str = Regex.Replace(str, "/\*.*?\*/", " ")
    let str = Regex.Replace(str, "/<!--/", " ")
    let str = Regex.Replace(str, "/-->/", " ")
    str.Trim()


type UserState = unit // doesn't have to be unit, of course
type Parser<'t> = Parser<'t, UserState>

// abbreviations
let ws = spaces

(* tokens
    At the token level we consume trailing whitespace
 *)

// identifier 
let identNoWs =
    let identifier =
        let isIdentifierFirstChar c = isLetter c || c = '_'
        let isIdentifierChar c = isLetter c || isDigit c || c = '_' || c = '-'
        many1Satisfy2L isIdentifierFirstChar isIdentifierChar "identifier"

    let prefixedIdentifier =
        pchar '-' >>. identifier |>> (fun ident -> "-" + ident)

    identifier <|> prefixedIdentifier

let identifier = identNoWs .>> ws // skips trailing whitespace

let stringLiteral2 : Parser<string> =
    let normalChar = satisfy (fun c -> c <> '\\' && c <> '"')
    let unescape c = match c with
                     | 'n' -> '\n'
                     | 'r' -> '\r'
                     | 't' -> '\t'
                     | c   -> c
    let escapedChar = pstring "\\" >>. (anyOf "\\nrt\"" |>> unescape)
    between (pstring "\"") (pstring "\"")
            (manyChars (normalChar <|> escapedChar)) .>> ws

let stringLiteral1 : Parser<string> =
    let normalChar = satisfy (fun c -> c <> '\\' && c <> '\'')
    between (pstring "'") (pstring "'")
            (manyChars normalChar) .>> ws

let stringLiteral = stringLiteral1 <|> stringLiteral2


// all CSS keywords are case insensitive
let keyword str = pstringCI str .>> ws

let symbol str = pstring str .>> ws

(* 
    Node selector syntax
    Qualifiers does not consume trailing whitespace
 *)
let attributeQualifier = pipe2 (symbol "[" >>. identifier) (symbol "=" >>. (identifier <|> stringLiteral) .>> symbol "]") (fun a b->AttributeValue(a,b))
let classQualifier = many1 (pchar '.' >>. identNoWs) |>> ClassQualifier
let idQualifier = pchar '#' >>. identNoWs |>> IdQualifier
let pseudoQualifier = pchar ':' >>. identNoWs |>> PseudoQualifier
let qualifier = (classQualifier  <|> idQualifier <|> pseudoQualifier <|> attributeQualifier)

let tagName = identNoWs |>> TypeSelector
let star = symbol "*" |>> (fun _ -> UniversalTypeSelector)
let typeSelector = tagName <|> star

// type and qualifiers can NOT be whitespace seperated
let nodeWithType = pipe2 typeSelector (many qualifier) (fun a b -> NodeSelector(a, b))
let nodeNoType = many1 qualifier |>> (fun b -> NodeSelector(UniversalTypeSelector, b))
let nodeSelector : Parser<NodeSelector> = (nodeWithType <|> nodeNoType) .>> ws

// context selectors
let childSelector = symbol ">" >>. nodeSelector |>> (fun a-> (Child, a))
let siblingSelector = symbol "+" >>. nodeSelector |>> (fun a-> (Sibling, a))
let descendentSelector = nodeSelector |>> (fun a-> (Descendant, a))
let contextSelector = childSelector <|> siblingSelector <|> descendentSelector

let transformSelectors (leftmost:NodeSelector) (selectors:(Axis*NodeSelector) list) =
    

    (* 
        convert list of contexts to a more semantic structure 
        We parse the combinator as part of the selector to the right
        but semantically it defines the left relative to the 'anchor' on the right

        ParseTree: 
            A       :: A
            A > B C :: A [(child, B) (descendent, C)]

        We transform to 
            A > B C :: (descendentOf C 
                           (childOf (B) 
                                (simple (A)))
    *)
    let rec transformSelectors1 context contextsLtoR =
        match contextsLtoR with
        | [] -> context
        | ((axis, childNodeSelector)::rest) ->
            let ctxSelector = 
                match axis with
                | Child -> ChildSelector(context)
                | Descendant -> DescendentSelector(context)
                | Sibling -> SiblingSelector(context)
            let context = ContextualSelector(childNodeSelector, ctxSelector)
            transformSelectors1 context rest

    transformSelectors1 (SimpleSelector(leftmost)) selectors

let selector = nodeSelector .>>. (many contextSelector) |>> (fun (a,b) -> transformSelectors a b)
let selectorList = sepBy selector (symbol ",")


(* terms *)
let numberFormat =     NumberLiteralOptions.AllowFraction
                   ||| NumberLiteralOptions.AllowFractionWOIntegerPart
                   ||| NumberLiteralOptions.AllowMinusSign
                   ||| NumberLiteralOptions.AllowPlusSign

let pdecimal : Parser<decimal, unit> =
    numberLiteral numberFormat "number"
    |>> fun nl -> decimal(nl.String)

let hexcolor = pstring "#" >>. many1Satisfy isHex .>> ws |>> HexColor
let unitOfMeasure = keyword "em" <|> keyword "%" <|> keyword "px" <|> keyword "ex" <|> keyword "pt" 
let value = pipe3 pdecimal (opt (unitOfMeasure)) ws
                (fun number dimension _ -> 
                    match dimension with
                                    | None -> Number(number)
                                    | Some dim -> Measure(number,dim))


// TODO: urls, strings, comma, slash

let term,termImpl = createParserForwardedToRef()
let garbageTerm = many1Satisfy (function ';'|'}' -> false | _ -> true) |>> IdentifierTerm
let funct = pipe2 identNoWs (symbol "(" >>. (many term) .>> symbol ")") (fun name terms->Function(name, terms))
let url = keyword "url(" >>. (stringLiteral <|> (charsTillString ")" false 4096)) .>> symbol ")" |>> Url
let stringTerm = stringLiteral |>> StringTerm
let identifierTerm = identifier |>> IdentifierTerm
let inherit1 = keyword "inherit" >>% Inherit
let unset = keyword "unset" >>% Unset

// a term prefixed by a minus -. could be an identifier or a negative number
(* using attempt here beacuse a token strating with '-' could be either numeric, function or identifier *)
let termValue = inherit1 <|> unset <|> (attempt value) <|> (attempt funct) <|> url <|> identifierTerm <|> hexcolor <|> stringTerm <|> garbageTerm
let term2 = pipe2 termValue 
                (opt (symbol "/" >>. termValue))
                (fun term slashArg ->   
                    match slashArg with
                    | None -> term
                    | Some term1 -> Slash(term,term1))
do termImpl := pipe2 term2
                (opt ((symbol ",") >>. (sepBy termValue (symbol ","))))
                (fun term commaArgs ->   
                    match commaArgs with
                    | None -> term
                    | Some termList -> TermList(term::termList))
let expr = many1 term

(* declarations syntax *)
let important = symbol "!" >>. keyword "important"
let declaration = pipe4 identifier (symbol ":") expr (opt important) (fun propName _ terms imp -> Declaration(propName, terms, imp.IsSome))
let declarations = sepEndBy declaration (symbol ";")

(* rules *)
let block = symbol "{" >>. declarations .>> symbol "}"
let ruleset = pipe2 selectorList block (fun a b->Ruleset(Rule(a, b)))
(* fro now we just ignore at-rules *)
let mediaQueryExpression = (symbol "(" >>. identifier >>. symbol ":" >>. value .>> symbol ")") |>> (fun x->"")
let mediaQueryPart = symbol "," <|> identifier <|> mediaQueryExpression
let mediaQueries = many mediaQueryPart
let atRule = keyword "@media" >>. mediaQueries >>. symbol "{" >>. (many ruleset) >>. symbol "}" |>> (fun a->AtRule("media"))
let statement = atRule <|> ruleset
let charset = keyword "@charset" >>. stringLiteral .>> symbol ";"
let stringUrl = stringLiteral |>> Url
let import = keyword "@import" >>. (url <|> stringUrl) .>> mediaQueries .>> symbol ";" |>> (function (Url(x)) -> Import(x))
let stylesheet = pipe2 ((opt charset) >>. many import)  (many statement) (fun imports stmts->Statements(imports,stmts))

(* 
    Individual productions consume whitespace at the end.
    this one runs a parser with prefixed whitespace consumer *)
let runWs parser src = run (ws >>. parser) src 

let runWs1 parser src = 
    let parserResult = runWs parser (preProcess src)
    match parserResult with
    | Success(result,_,_) -> result

/// Parses a stylesheet
let parseStyleSheet src : Statements = runWs1 stylesheet src 

/// Parses a set of declarations, like in the style-attribute
let parseDeclarations src : Declaration list = runWs1 declarations src 
